home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-03
/
dosbasic.zip
/
DEMO.BAS
< prev
next >
Wrap
BASIC Source File
|
1990-12-19
|
14KB
|
535 lines
'===========================================================================
'DOS/UTILITY routines
'UPDATED 12/18/90
'ErrorHandler IS REQUIRED!!!
'Necessary for graceful recovery of errors
'===========================================================================
DEFINT A-Z
REM $INCLUDE: 'DFILE.BI'
'Draws Boxes on the Screen, I have faster MASM video routines in
'VIDBASIC.ZIP
DECLARE SUB Box (ULR%, ULC%, LRR%, LRC%, TitleMen%)
'Returns Current Filename in DOS version 3.xx and above
DECLARE SUB GetCurrentFile (FileName$)
'Gets current path and drive
DECLARE FUNCTION GetCurrPath$ ()
'Returns current physical and logical drive information
DECLARE SUB DriveInfo ()
'Select attractive cursor and screen color
DECLARE SUB BackGround ()
DIM SHARED ErrCode%
DIM SHARED PATH AS STRING * 64
CONST False = 0, True = NOT False
'saves space
DIM SHARED Zero$: Zero$ = CHR$(0)
DIM SHARED Bgrnd% 'so we can keep track of display color
CALL BackGround
CLS 'clear display to background color
ULR = 1: ULC = 1: LRR = 25: LRC = 80: TitleMen = 1
CALL Box(ULR%, ULC%, LRR%, LRC%, TitleMen%) 'draw title screen box
LOCATE 2, 15
COLOR Bgrnd%, 7
PRINT "System Information Routines (C) Copr. 1990 - SJKelly"
COLOR 7, Bgrnd%
CALL HARDRIVES(HARD%) 'select default drive"
T$ = LEFT$(COMMAND$, 1) 'unless something different entered
IF LEN(T$) = 0 THEN 'at command line when start program
IF HARD% THEN
T$ = "C"
ELSE
T$ = "A"
END IF
END IF
T$ = UCASE$(T$)
LOCATE 3, 15
PRINT "Processors: ";
TCPU% = GETCPU%
SELECT CASE TCPU%
CASE 20
PRINT "NEC V20";
CASE 30
PRINT "NEC V30";
CASE ELSE
PRINT "80" + LTRIM$(STR$(TCPU%));
END SELECT
TNDP% = CHECK87%
PRINT " with";
SELECT CASE TNDP%
CASE 0
PRINT "out a math";
CASE -87
PRINT " a software emulator";
CASE 87
PRINT " an 8087";
CASE 287
PRINT " an 80287";
CASE 387 'cannot distinguish between 487 & 387 except for speed
PRINT " an 80387";
END SELECT
PRINT " coprocessor."
'get information about available memory
CALL OTHERMEMORY(EXTENDED%, EXPANDED%, XMS%)
'get some regular information too
CALL EQUIPMENT(RegMem%, NoPrinters%, ComPorts%)
LOCATE 5, 3
PRINT "Memory in KB: "; RegMem%; "DOS,";
PRINT EXPANDED%; "EMS & "; XMS%; "XMS."
LOCATE , 3
IF ACTUALEXTND < 0 THEN
PRINT "CMOS battery is about dead, better replace it."
ELSE
PRINT "Actual Extended:"; ACTUALEXTND%; "kb"; TAB(42);
PRINT "Free Extended:"; EXTENDED%; "kb."
END IF
LOCATE , 3
Ansi = ANSICHECK%
PRINT "ANSI Driver: ";
IF Ansi THEN
PRINT "IS installed.";
ELSE
PRINT "NOT installed.";
END IF
PRINT
VERSION$ = SPACE$(4)
CALL GETDOSVER(VERSION$)
LOCATE , 3
PRINT "DOS Version: "; VERSION$;
'check if we are operating under a multitasking environment
CALL OTHEROPER(DPMI%, WINDOWS%, DESQVIEW)
PRINT TAB(42); "Multitasker:";
IF (DPMI + WINDOWS + DESQVIEW) THEN
IF DPMI% THEN PRINT " DPMI";
IF WINDOWS% THEN PRINT " WINDOWS";
IF DESQVIEW% THEN PRINT " DESQVIEW";
PRINT
ELSE
PRINT " None."
END IF
PRINT
LOCATE , 3
FOR x = 1 TO NoPrinters
IF PRINTRDY%(x) THEN
PRINT "LPT"; CHR$(x + 48); ": printer ready. ";
ELSE
PRINT "LPT"; CHR$(x + 48); ": printer error. ";
END IF
NEXT
PRINT
LOCATE , 3
PRINT "You have"; ComPorts; "COM ports installed."
PRINT
CALL GetCurrentFile(FileName$)
LOCATE , 3
PRINT "Current file name: "; FileName$
IF LEN(FileName$) = 0 THEN FileName$ = "QB.EXE"
'need to trap open doors & invalid drives
ON ERROR GOTO ErrorHandler
'strip off the leading drive and subdirectory names
DO
FileName$ = MID$(FileName$, INSTR(FileName$, "\") + 1)
IF INSTR(FileName$, "\") = 0 THEN EXIT DO
LOOP
Mode% = 0 '0 means normal read access, <> 0 means read/write access
CALL EXIST(FileName$ + Zero$, ErrCode%, Mode%)
LOCATE , 3
IF ErrCode% THEN
PRINT "Sorry, "; FileName$; " not found in current directory."
ELSE
PRINT FileName$; " found in current directory."
END IF
FirstDrive$ = "z:"
CALL GETDRIVE(FirstDrive$)
LOCATE , 3
PRINT "Changing Drive to Drive "; T$; ":";
CALL SETDRIVE(T$, ErrCode%)
LOCATE , 3
IF ErrCode% THEN
PRINT "Drive invalid, old value retained.";
ELSE
CALL SUBSTDRIVE(T$, ErrCode%)
IF (ErrCode% = 2) THEN
PRINT "Drive "; T$; " is a SUBST drive."
ELSE
PRINT
END IF
END IF
LOCATE , 3
PRINT "Current Drive and Path is "; GetCurrPath$;
IF ErrCode% THEN
PRINT " Error reported."
ELSE
PRINT
END IF
CALL DRVSPACE(T$, F&)
LOCATE , 3
IF F& = 0 THEN
PRINT "Selected drive was invalid."
ELSE
PRINT "Drive "; T$; ": has";
PRINT USING "##########,"; F&;
PRINT " Bytes free."
END IF
PRINT
'return to where we started, assume still valid
LOCATE , 3
PRINT "Returning to Original Drive: "; FirstDrive$
CALL SETDRIVE(FirstDrive$, ErrCode%)
'turn off error checking to show how the following routines work
ON ERROR GOTO 0
CALL DriveInfo
LOCATE 23, 1
DO 'Wait until Key press
LOOP UNTIL LEN(INKEY$)
SCREEN 0, , 0, 0
CLS
ULR = 9: ULC = 1: LRR = 25: LRC = 80: TitleMen = 1
CALL Box(ULR%, ULC%, LRR%, LRC%, TitleMen%) 'draw title screen box
LOCATE 10, 3
PRINT "The MASM routines used by this DEMO are";
LOCATE 11, 9
TemHead$ = "Copr. Copyright (C) 1990, Sidney J. Kelly, All rights Reserved."
PRINT TemHead$;
LOCATE 13, 3
PRINT "Your ROM BIOS shows the following information:"
LOCATE 15, 3
PRINT "ROM BIOS date is: "; SPC(24);
RomDate$ = SPACE$(8)
SegAddress% = &HFFFF: OffAddress% = &H5
CALL MEM2STRING(RomDate$, SegAddress%, OffAddress%)
PRINT RomDate$
LOCATE 16, 3
CopyRight$ = SPACE$(90)
SegAddress% = &HFE00: OffAddress% = &H0
CALL MEM2STRING(CopyRight$, SegAddress%, OffAddress%)
Temp$ = UCASE$(CopyRight$) 'squeeze out unnecessary information
Lengt = LEN(CopyRight$)
Temp = INSTR(Temp$, "CO")
CopyRight$ = RTRIM$(RIGHT$(CopyRight$, Lengt - Temp + 1))
PRINT "ROM: "; CopyRight$
LOCATE 18, 3
CALL DRIVEALIAS(ASSIGN%, DAPPEND%, NETWORK%, SHARE%)
PRINT "ASSIGN is: ";
IF ASSIGN THEN
PRINT "active. ";
ELSE
PRINT "inactive. ";
END IF
PRINT TAB(32); "APPEND is: ";
IF DAPPEND THEN
PRINT "active."
ELSE
PRINT "inactive."
END IF
LOCATE 19, 3
PRINT "MS NETWORK is: ";
IF NETWORK THEN
PRINT "active. ";
ELSE
PRINT "inactive. ";
END IF
PRINT TAB(32); "SHARE is: ";
IF SHARE THEN
PRINT "active."
ELSE
PRINT "inactive."
END IF
LOCATE 24, 27
COLOR Bgrnd%, 7
PRINT "Press any key to quit.";
COLOR 7, Bgrnd%
DO 'Wait until Key press
LOOP UNTIL LEN(INKEY$)
CLS
LOCATE 10, 3
PRINT "The MASM routines used by this DEMO are now printed backwards";
LOCATE 11, 1
CALL REVERSESTRING(TemHead$)
PRINT TemHead$
SLEEP 1
CALL REVERSESTRING(TemHead$)
PRINT TemHead$
SLEEP 1
'need an end to avoid crashing into ErrorHandler
END
'Necessary for graceful recovery of errors
ErrorHandler:
SELECT CASE ERR
CASE 53, 76 'File does not exist, an expected error
RESUME NEXT
CASE 75 'File does not exist, an expected error
RESUME NEXT
CASE 57, 68 'Drive is invalid generating an I/O error
ErrCode = True
RESUME NEXT
CASE 64 '"Bad filename", an expected error
RESUME NEXT
CASE 71 'door open on the drive
ErrCode% = True
RESUME NEXT
CASE ELSE
LOCATE , 3
PRINT " Error occurred:"; ERR
END SELECT
'==============================Background===================================
' Selects a nice background and cursor size
' depending on the type of CRT
' QBASIC selects a cursor that is properly sized only for the CGA
' Updated 1/9/90
'===========================================================================
SUB BackGround STATIC
'Check BIOS area of RAM
DEF SEG = &H40
'CRTMode = PEEK(&H63) 'Check CRT port
IF PEEK(&H63) = &HB4 THEN
'if CRTMode = &HB4 then CRTMode is a Mono display
Bgrnd% = 0 'use a black background
LOCATE , , , 12, 13 'Pleasant cursor size
ELSE
'else a Color display (correct for EGA/VGA only if cursor
'emulation is on).
Bgrnd% = 1 'use a blue background. However,
'on a COMPAQ portable or EGA/VGA monochrome
'this is NOT attractive.
LOCATE , , , 6, 7 'Pleasant cursor size
END IF
COLOR 7, Bgrnd%
'restore Def Seg
DEF SEG
'Note a VGA can appear as a color or mono display depending upon
'the current BIOS mode and depending if monitor was on when the machine
'was turned on.
END SUB
'------------------------------Draw Boxes------------------------------------
' DRAW A BOX AT SPECIFIED COORDINATES
' This is a generic routine that can be used to draw a box anywhere.
' ULR% is the starting row. ULC% is the starting column.
' LRR% is the ending row. LRC% is the ending column.
' If the paramater TitleMen% is > 0, then prints horizontal bars
' three rows down from the top of the box and two rows up from the bottom.
' If TitleMen% is set to 0, the routine will print a plain box.
' This can create a quick frame for a title screen.
'
' In my VIDBASIC library is a much faster MASM routine. This routine is
' added because it is generic and needs no MASM support
'----------------------------------------------------------------------------
SUB Box (ULR%, ULC%, LRR%, LRC%, TitleMen%) STATIC
'to make the definitions local to routine
STATIC BoxTop, BoxTop$, BoxBottom$, BoxMiddle$
'CONST is used for speed
CONST BoxSide$ = "║" 'box side CHR$(186)
CONST UpLeft$ = "╔" 'upper left CHR$(201)
CONST UpRight$ = "╗" 'upper right CHR$(187)
CONST LowLeft$ = "╚" 'lower left CHR$(200)
CONST LowRight$ = "╝" 'lower right CHR$(188)
CONST LeftTee$ = "╠" 'left T CHR$(204)
CONST RightTee$ = "╣" 'right T CHR$(185)
'The first piece of code sets up the strings for box drawing
BoxTop = (LRC% - ULC%) - 1
IF BoxTop < 0 THEN BoxTop = 0 'keep variable within range
BoxTop$ = UpLeft$ + STRING$(BoxTop, 205) + UpRight$
BoxBottom$ = LowLeft$ + STRING$(BoxTop, 205) + LowRight$
'This prints the top of the box
LOCATE ULR%, ULC%: PRINT BoxTop$;
'Print the sides of the box
FOR E1% = ULR% + 1 TO LRR% - 1
LOCATE E1%, ULC%: PRINT BoxSide$;
LOCATE E1%, LRC%: PRINT BoxSide$;
NEXT
'Print the bottom of the box
LOCATE LRR%, ULC%: PRINT BoxBottom$;
'Optionally prints horizontal lines at top and bottom of the box
'To set up title and menu screens.
IF TitleMen% > 0 THEN
BoxMiddle$ = LeftTee$ + STRING$(BoxTop, 205) + RightTee$
LOCATE ULR% + 3, ULC%: PRINT BoxMiddle$;
LOCATE LRR% - 2, ULC%: PRINT BoxMiddle$;
END IF
'speed up garbage collection and allow use of STATIC
BoxTop$ = "": BoxBottom$ = "": BoxMiddle$ = ""
END SUB
'===========================================================================
' Returns information concerning logical and physical drives
'
' Updated 6/20/90
'===========================================================================
SUB DriveInfo STATIC
DirNos% = FINDDRIVES%
LOCATE , 3
PRINT "Logical Drives: ";
PRINT " A: to " + CHR$(64 + DirNos%) + ":"
CALL FLOPPYDRIVES(NoDrives%)
CALL HARDRIVES(HARD%)
LOCATE , 3
PRINT "Physical Drives: "; HARD%;
PRINT "Hard Drive(s),"; NoDrives%; "Floppy Drive(s)."
LOCATE , 3
IF NoDrives = 1 THEN
DEF SEG = 0
Mimic = PEEK(&H504)
DEF SEG
PRINT "Drive A: is currently acting as Drive ";
'Mimic = 0 if acting as A:, 1 if B: and 255 if never used drive A
IF (Mimic = 1) THEN
PRINT "B:"
ELSE
PRINT "A:"
END IF
END IF
Drive$ = "A:"
CALL FLOPPYREADY(Drive$, ErrCode%)
LOCATE 24, 3
PRINT "Floppy Drive "; Drive$;
SELECT CASE ErrCode%
CASE 0
PRINT " is valid and has the door closed.";
CASE 128
PRINT " has its door open.";
CASE 80
PRINT " has a track error.";
CASE -1
PRINT " is not valid.";
END SELECT
END SUB
'===========================================================================
' Returns the current running file name based on the current
' PSP for the program.
' Works in DOS version 3.xx and above.
' Inside QB.EXE will always report QB.EXE
' Updated 7/20/90
'===========================================================================
SUB GetCurrentFile (FileName$) STATIC
FileName$ = SPACE$(64)
CALL GETCURRENTNAME(FileName$, FileNameLen%)
IF FileNameLen% > 0 THEN
FileName$ = UCASE$(LEFT$(FileName$, FileNameLen%))
ELSE
FileName$ = ""
END IF
END SUB
'===========================================================================
' Returns Complete Current Drive and Path$
' Also detects if SUBST, ASSIGN, JOIN are at work
' Updated 9/26/90
'===========================================================================
FUNCTION GetCurrPath$ STATIC
STATIC D$, T$, P$
ErrCode% = False%
T$ = SPACE$(67)
CALL GETFULLPATH(T$, PATHLEN%)
IF (PATHLEN% = -1) OR ErrCode% THEN
GetCurrPath$ = ""
T$ = ""
EXIT FUNCTION
END IF
T$ = LEFT$(T$, PATHLEN%)
D$ = ".": P$ = SPACE$(67)
CALL TRUENAME(D$ + Zero$, P$, FileLen%)
SELECT CASE FileLen
CASE 0
'Dos Version 2.xx so TrueName wont work & SHARE, ASSIGN
'SUBST, & JOIN are by definition inactive
CASE -1
PRINT " Current Path$ contains unknown error.": END
CASE 1 TO 67
P$ = LEFT$(P$, FileLen%)
IF P$ <> T$ THEN
PRINT " Warning! ASSIGN, JOIN, or SUBST active."
PRINT " Please remove from BATCH files and reboot!!"
T$ = "Error r r r"
END IF
CASE ELSE
END SELECT
GetCurrPath$ = T$
T$ = "": D$ = "": P$ = ""
END FUNCTION